home *** CD-ROM | disk | FTP | other *** search
/ Monster Media 1996 #14 / Monster Media No. 14 (April 1996) (Monster Media, Inc.).ISO / prog_bas / vberr_16.zip / VBERR-16.BAS < prev    next >
BASIC Source File  |  1996-01-07  |  10KB  |  320 lines

  1. Attribute VB_Name = "vbErrorHandler_bas"
  2. Option Explicit
  3.  
  4. Global Const VB_LNG_FRENCH = 1
  5. Global Const VB_LNG_DUTCH = 2
  6. Global Const VB_LNG_GERMAN = 3
  7. Global Const VB_LNG_ENGLISH = 4
  8. Global Const VB_LNG_ITALIAN = 5
  9. Global Const VB_LNG_SPANISH = 6
  10. Global Const VB_LNG_CATALAN = 7
  11. Global Const VB_LNG_POLISH = 8
  12.  
  13. Const MB_MESSAGE_LEFT = 0
  14.  
  15. Declare Sub cPushID Lib "vbhnd-16.dll" (IDArray As Integer, ByVal nID As Integer)
  16. Declare Sub cPopID Lib "vbhnd-16.dll" (IDArray As Integer, ByVal nID As Integer)
  17. Declare Sub cPopLastID Lib "vbhnd-16.dll" (IDArray As Integer)
  18. Declare Function cGetID Lib "vbhnd-16.dll" (IDArray As Integer, ByVal nPosition As Integer) As Integer
  19. Declare Sub cClearID Lib "vbhnd-16.dll" (IDArray As Integer)
  20. Declare Sub cChangeChars Lib "vbhnd-16.dll" (Txt As String, CharSet As String, NewCharSet As String)
  21. Declare Function cGetIni Lib "vbhnd-16.dll" (ByVal AppName As String, ByVal szItem As String, ByVal szDefault As String, ByVal InitFile As String) As String
  22. Declare Function cGetWindowsDirectory Lib "vbhnd-16.dll" () As String
  23. Declare Function cInsertBlocks Lib "vbhnd-16.dll" (Txt As String, Insert As String) As String
  24. Declare Function cLngMsgBox Lib "vbhnd-16.dll" (ByVal nLanguage As Integer, ByVal Message As String, ByVal Button As Long, ByVal Title As String) As Integer
  25.  
  26. 'Don't change any variables and their value below
  27.  
  28. Const ID_ITEMS = 16
  29.  
  30. Type HNDERRtype
  31.    ModuleName                       As String * 12
  32.    RoutineHandle                    As String * 4
  33.    RoutineName                      As String * 82
  34.    CrLf                             As String * 2
  35. End Type
  36.  
  37. Dim FileLNG                         As String
  38.  
  39. Dim FileHND                         As String
  40.  
  41. Dim FileLOG                         As String
  42.  
  43. Dim IDArray(0 To ID_ITEMS)          As Integer
  44.  
  45. Dim Language                        As Integer
  46. Dim AutoLog                         As Integer
  47. Dim WaitingTimeForReaction          As Integer
  48. Dim DefaultButton                   As Integer
  49. Dim DisplayOnline                   As Integer
  50.  
  51. Dim TotalSameHandle                 As Long
  52. Dim LastHandle                      As Integer
  53. Dim ChanHandle                      As Integer
  54. Dim OldChanHandle                   As Integer
  55.  
  56. Dim HNDERR                          As HNDERRtype
  57.  
  58. Sub mcClearID()
  59.    Call cClearID(IDArray(0))
  60. End Sub
  61.  
  62. Function mcGetID(nPos As Integer)
  63.    mcGetID = cGetID(IDArray(0), nPos)
  64. End Function
  65.  
  66. Function mcGetLanguageID(LanguageID As Integer) As String
  67.  
  68.    Dim RetLanguage      As String
  69.  
  70.    Select Case LanguageID
  71.       Case VB_LNG_FRENCH
  72.          RetLanguage = "VFR"
  73.       Case VB_LNG_DUTCH
  74.          RetLanguage = "VNL"
  75.       Case VB_LNG_GERMAN
  76.          RetLanguage = "VDE"
  77.       Case VB_LNG_ENGLISH
  78.          RetLanguage = "VUK"
  79.       Case VB_LNG_ITALIAN
  80.          RetLanguage = "VIT"
  81.       Case VB_LNG_SPANISH
  82.          RetLanguage = "VSP"
  83.       Case VB_LNG_POLISH
  84.          RetLanguage = "VPO"
  85.       Case VB_LNG_CATALAN
  86.          RetLanguage = "VCA"
  87.       Case Else
  88.          RetLanguage = "VUK"
  89.    End Select
  90.    
  91.    If (LanguageID > 0) Then
  92.       Language = LanguageID
  93.    Else
  94.       Language = VB_LNG_ENGLISH
  95.    End If
  96.  
  97.    mcGetLanguageID = RetLanguage
  98.  
  99. End Function
  100.  
  101. Function mcIDErrorHandler(nErr As Integer) As Integer
  102.  
  103.    ' check if this a correct Error passed
  104.    If (nErr = 0) Then
  105.       'if no, resume next
  106.       mcIDErrorHandler = True
  107.       Exit Function
  108.    End If
  109.  
  110.    Dim RoutineCount     As Integer
  111.    Dim RoutineNumber    As Integer
  112.    Dim RoutineStack     As String
  113.    Dim TotalRoutines    As Integer
  114.    Dim BlankLines       As Integer
  115.    Dim Chan             As Integer
  116.    Dim StopExit         As Integer
  117.    Dim TimeOut          As Long
  118.    Dim ButtonsConfig    As Integer
  119.    Dim ErrorTitle       As String
  120.  
  121.    '  some initializations
  122.    RoutineStack = ""
  123.    TotalRoutines = 0
  124.    BlankLines = 0
  125.    StopExit = False
  126.    ButtonsConfig = 0
  127.    ErrorTitle = ""
  128.    RoutineStack = RoutineStack + mcReadText("0", "")
  129.    
  130.    ' find the next valid unused file number.
  131.    Chan = FreeFile
  132.  
  133.    ' open the file with the definition of each routines (file must be in the WINDOWS directory)
  134.    Close #Chan
  135.    Open FileHND For Random Shared As #Chan Len = Len(HNDERR)
  136.  
  137.    ' get the stack of the routines
  138.    For RoutineCount = 0 To ID_ITEMS
  139.       ' get the number of the routine
  140.       RoutineNumber = mcGetID(RoutineCount)
  141.       ' if there a valid routine number
  142.       If (RoutineNumber > 0) Then
  143.          ' yes, read the definition of the routine
  144.          Get #Chan, RoutineNumber, HNDERR
  145.          ' form the stack of the routines founden to display
  146.          RoutineStack = RoutineStack + Left$(HNDERR.ModuleName + Space$(12), 14) + Chr$(9) + HNDERR.RoutineHandle + Chr$(9) + Trim$(HNDERR.RoutineName) + Chr$(13)
  147.          ' count the routines to display
  148.          TotalRoutines = TotalRoutines + 1
  149.       Else
  150.          ' no, exit from reading the stack
  151.          Exit For
  152.       End If
  153.    Next RoutineCount
  154.  
  155.    ' close the open file
  156.    Close #Chan
  157.  
  158.    ' check if the default button must be activated
  159.    If (DefaultButton = True) Then
  160.       ' yes, RETRY and CANCEL with RETRY is the default
  161.       ButtonsConfig = 5 Or 0
  162.    Else
  163.       ' no, RETRY and CANCEL with CANCEL is the default
  164.       ButtonsConfig = 5 Or 256
  165.       ' yes, add text for RETRY after timeout or action
  166.       RoutineStack = RoutineStack & Chr$(13) & Chr$(13) & "program will be stopped"
  167.    End If
  168.  
  169.    ' set the error title
  170.    ErrorTitle = mcReadText("1", nErr & "~" & Error$(nErr))
  171.  
  172.    ' check if one routine has been founded
  173.    If (Len(RoutineStack) > 0) Then
  174.       ' check the time out
  175.       TimeOut = WaitingTimeForReaction * (163840 Or 524288)
  176.       ' display remaining blank lines
  177.       BlankLines = (8 - TotalRoutines) - (TimeOut = 0)
  178.       For RoutineCount = 0 To BlankLines
  179.          RoutineStack = RoutineStack + Chr$(13)
  180.       Next RoutineCount
  181.       ' add some text for management
  182.       RoutineStack = RoutineStack & mcReadText("2", "")
  183.       ' check if a timeout must be used
  184.       If (TimeOut <> 0) Then
  185.          ' yes, add text depending of the default button
  186.          RoutineStack = RoutineStack & mcReadText("3", "") & " "
  187.          ' if default is RETRY then display 'continue' else 'stop'
  188.          If (DefaultButton = True) Then
  189.             RoutineStack = RoutineStack & mcReadText("4", "")
  190.          Else
  191.             RoutineStack = RoutineStack & mcReadText("5", "")
  192.          End If
  193.       End If
  194.       ' display the error message box
  195.       StopExit = (cLngMsgBox(Language, RoutineStack, MB_MESSAGE_LEFT Or TimeOut Or ButtonsConfig Or 16, ErrorTitle) = 2)
  196.       ' yield process
  197.       DoEvents
  198.    End If
  199.  
  200.    ' check if an auto logging must be performed
  201.    If (AutoLog = True) Then
  202.  
  203.       ' open the logging file in append mode
  204.       Close #Chan
  205.       Open FileLOG For Append Shared As #Chan
  206.  
  207.       ' save the error and his description
  208.       Print #Chan, ErrorTitle; " "; mcReadText("6", Date$ & "~" & Time$)
  209.       Print #Chan, ""
  210.       ' save the full stack name of each routines founden
  211.       Print #Chan, RoutineStack
  212.       Print #Chan, ""
  213.       ' check if the CANCEL button pushed or TimeOut
  214.       If (StopExit = True) Then
  215.          ' yes stop by operator, save text for CANCEL
  216.          Print #Chan, mcReadText("7", "")
  217.       Else
  218.          ' no, retry by operator, save text for RETRY
  219.          Print #Chan, mcReadText("8", "")
  220.       End If
  221.       ' save separator
  222.       Print #Chan, String$(78, "-")
  223.  
  224.       ' close the file
  225.       Close #Chan
  226.  
  227.    End If
  228.  
  229.    ' if stop the program the END the application
  230.    If (StopExit = True) Then End
  231.  
  232.    ' no stop, resumes to next line in the main application
  233.    mcIDErrorHandler = True
  234.  
  235. End Function
  236.  
  237. Sub mcOnlineDisplay(ID As Integer)
  238.  
  239.    Dim ActualLine    As String
  240.  
  241.    If (ChanHandle = -1) Then
  242.  
  243.       ' close the old chan if more than 1 mcInitID is called
  244.       If (OldChanHandle <> -1) Then Close #OldChanHandle
  245.  
  246.       ' find the next valid unused file number.
  247.       ChanHandle = FreeFile
  248.  
  249.       ' open the file with the definition of each routines (file must be in the WINDOWS directory)
  250.       Close #ChanHandle
  251.       Open FileHND For Random Shared As #ChanHandle Len = Len(HNDERR)
  252.  
  253.       ' save the handle
  254.       OldChanHandle = ChanHandle
  255.  
  256.    End If
  257.  
  258.    ' read the handle
  259.    Get #ChanHandle, ID, HNDERR
  260.  
  261.    If (LastHandle = ID) Then
  262.       TotalSameHandle = TotalSameHandle + 1
  263.    Else
  264.       If (frmDisplayOnline.lstOnline.ListIndex > -1) Then
  265.          ActualLine = frmDisplayOnline.lstOnline.List(frmDisplayOnline.lstOnline.ListIndex)
  266.          frmDisplayOnline.lstOnline.List(frmDisplayOnline.lstOnline.ListIndex) = TotalSameHandle & Mid$(ActualLine, InStr(ActualLine, Chr$(9)))
  267.       End If
  268.       TotalSameHandle = 1
  269.    End If
  270.  
  271.    frmDisplayOnline.lblCounter = TotalSameHandle
  272.    frmDisplayOnline.lblHandle = ID
  273.  
  274.    If (LastHandle <> ID) Then
  275.       frmDisplayOnline.lstOnline.AddItem TotalSameHandle & Chr$(9) & Trim$(HNDERR.RoutineHandle) & Chr$(9) & Trim$(HNDERR.ModuleName) & Chr$(9) & Trim$(HNDERR.RoutineName)
  276.       If (frmDisplayOnline.lstOnline.ListCount > 25) Then frmDisplayOnline.lstOnline.RemoveItem 0
  277.       frmDisplayOnline.lstOnline.ListIndex = frmDisplayOnline.lstOnline.NewIndex
  278.    End If
  279.  
  280.    LastHandle = ID
  281.  
  282.    DoEvents
  283.  
  284. End Sub
  285.  
  286. Sub mcPopID(ID As Integer)
  287.    Call cPopID(IDArray(0), ID)
  288. End Sub
  289.  
  290. Sub mcPopLastID()
  291.    Call cPopLastID(IDArray(0))
  292. End Sub
  293.  
  294. Sub mcPushID(ID As Integer)
  295.  
  296.    Call cPushID(IDArray(0), ID)
  297.  
  298.    If (DisplayOnline = True) Then Call mcOnlineDisplay(ID)
  299.  
  300. End Sub
  301.  
  302. Function mcReadText(TextOrder As String, InsertText As String) As String
  303.  
  304.    Dim Tmp              As String
  305.    Dim BasisText        As String
  306.  
  307.    ' read the text in the language file
  308.    BasisText = cGetIni("VBHND-16", TextOrder, "?", FileLNG)
  309.    
  310.    ' insert some text if any
  311.    Tmp = cInsertBlocks(BasisText, InsertText)
  312.  
  313.    ' change all º by a CR and all ú by TAB
  314.    Call cChangeChars(Tmp, "ºú", Chr$(13) + Chr$(9))
  315.  
  316.    mcReadText = Tmp
  317.  
  318. End Function
  319.  
  320.